Giga Games 1/Giga Games.iso/net/vir_real/veos/part06

Internet Message Format | 1993-06-20 | 83.0 KB

Path: wupost!uunet!decwrl!vixie!vixie!not-for-mail
From: [e-mail] (Geoffery Coco)
Newsgroups: comp.sources.unix
Subject: v26i189: veos-2.0 - The Virtual Environment Operating Shell, V2.0, Part06/16
Date: 25 Apr 1993 23:15:05 -0700
Organization: Vixie Home Computing
Lines: 3033
Sender: [e-mail]
Approved: [e-mail]
Message-ID: <1rful9$[e-mail]>
NNTP-Posting-Host: efficacy.home.vix.com

Submitted-By: [e-mail] (Geoffery Coco)
Posting-Number: Volume 26, Issue 189
Archive-Name: veos-2.0/part06

#! /bin/sh
# This is a shell archive.  Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file".  To overwrite existing
# files, type "sh file -c".  You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g..  If this archive is complete, you
# will see the following message at the end:
#        "End of archive 6 (of 16)."
# Contents:  src/utils/xv_utils.c src/xlisp/xcore/c/unixstuff.c
#   src/xlisp/xcore/c/xlfio.c src/xlisp/xcore/c/xlisp.h
#   src/xlisp/xcore/c/xlmath.c src/xlisp/xcore/c/xlstruct.c
# Wrapped by [e-mail] on Sun Apr 25 23:10:37 1993
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'src/utils/xv_utils.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'src/utils/xv_utils.c'\"
else
echo shar: Extracting \"'src/utils/xv_utils.c'\" \(13040 characters\)
sed "s/^X//" >'src/utils/xv_utils.c' <<'END_OF_FILE'
X/****************************************************************************************
X *                                            *
X * file: xv_utils.c                                    *
X *                                            *
X * Sundry lisp utils for the veos project                        *
X *                                            *
X * creation: March 28, 1991                                *
X *                                            *
X *                                            *
X * Includes utilities by:                                *
X *                                            *
X *    Geoff Coco                                    *
X *    Dav Lion                                    *
X *    Andy McDonald                                    *
X *    Fran Taylor                                    *
X *                                            *
X ****************************************************************************************/
X
X/****************************************************************************************
X * Copyright (C) 1992  Human Interface Technology Lab, Seattle                *
X ****************************************************************************************/
X
X#include "xlisp.h"
X#include "world.h"
X#include <math.h>
X#include <sys/time.h>
X
Xextern LVAL    true;
X
Xtypedef float     TMatrix[4][4];
Xtypedef float     TTriple[3];
Xtypedef float     TVector[4];
X
XLVAL ReverseList();
Xboolean IsTripleElt();
X
X
X/****************************************************************************************/
XLVAL read_time ()
X{
X  struct timeval t;
X  double          now, diff;
X  static double then = 0.0;
X  int            err;
X
X  err = gettimeofday( &t, 0);
X/*
X  fprintf( stderr, "%d %d\n", t.tv_sec, t.tv_usec);
X*/
X  if( err == -1)
X    xlerror( "read-time: timer barfed");
X  else
X    {
X      now = (double)t.tv_sec + (double)t.tv_usec / 1000000.0;
X/*
X      fprintf( stderr, "%f %f\n", now, then);
X*/
X      diff = now - then;
X      then = now;
X    }
X  return cvflonum( diff);
X}
X/****************************************************************************************/
X
X
X
X/****************************************************************************************
X *.native_sprintf -- data conversion.                            *
X ****************************************************************************************/
X
XLVAL native_sprintf()
X{
X    str255    sLocal;
X
X    util_sprintf(sLocal);
X
X    return(cvstring(sLocal));
X
X    } /* native_sprintf */
X/****************************************************************************************/
X
X
X/****************************************************************************************
X *.native_printf -- data conversion.                            *
X ****************************************************************************************/
X
XLVAL native_printf()
X{
X    str255    sLocal;
X
X    util_sprintf(sLocal);
X    fprintf(stderr, "%s\n", sLocal);
X
X    return(true);
X
X    } /* native_printf */
X/****************************************************************************************/
X
X
X
X/****************************************************************************************
X *.native_printf1 -- data conversion.                            *
X ****************************************************************************************/
X
XLVAL native_printf1()
X{
X    str255    sLocal;
X
X    util_sprintf(sLocal);
X    fprintf(stderr, "%s", sLocal);
X
X    return(true);
X
X    } /* native_printf1 */
X/****************************************************************************************/
X
X
X/****************************************************************************************/
XTVeosErr util_sprintf(sDest)
X    char    *sDest;
X{
X    LVAL    pXElt;
X    str63    sZoot;
X
X    sDest[0] = '\0';
X
X    while (moreargs()) {
X
X    pXElt = xlgetarg();
X
X    if (!null(pXElt)) {
X
X        switch (ntype(pXElt)) {
X
X        case FIXNUM:
X        sprintf(sZoot, "%d", getfixnum(pXElt));
X        strcat(sDest, sZoot);
X        break;
X
X        case FLONUM:
X        sprintf(sZoot, "%.2f", getflonum(pXElt));
X        strcat(sDest, sZoot);
X        break;
X
X        case STRING:
X        strcat(sDest, (char *) getstring(pXElt));
X        break;
X
X        default:
X        break;
X        }
X        }
X    }
X
X    return(VEOS_SUCCESS);
X
X    } /* util_sprintf */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************
X *.native_sscanf -- data conversion.                            *
X ****************************************************************************************/
X
XLVAL native_sscanf()
X{
X    LVAL    pData;
X    LVAL    pList, pXElt;
X    char    *pDataFinger;
X
X    xlsave1(pList);
X    xlsave1(pXElt);
X
X    pData = xlgastring();
X    xllastarg();
X
X    pDataFinger = (char *) getstring(pData);
X    while (pDataFinger) {
X
X    /** skip white space **/
X
X    while (pDataFinger[0] == ' ')
X        pDataFinger ++;
X
X    if (pDataFinger[0] == '\0')
X        break;
X
X    /** StrToXElt() looks for ' ' or '\0' as delimiter **/
X
X    StrToXElt(pDataFinger, &pXElt);
X    pList = cons(pXElt, pList);
X
X    pDataFinger = strchr(pDataFinger, ' ');
X    }
X
X    pList = ReverseList(pList);
X
X    xlpopn(2);
X
X    return(pList);
X
X    } /* native_sscanf */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************/
XTVeosErr XVUtils_LoadPrims()
X{
X    Xform_LoadPrims();
X
X#define UTIL_LOAD
X#include "xv_utils.h"
X#undef UTIL_LOAD
X
X    }
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************
X * StrToXElt                                         */
X
XTVeosErr StrToXElt(sData, hXElt)
X    char        *sData;
X    LVAL        *hXElt;
X{
X    TVeosErr         iErr;
X    char        *pFinger, cSave;
X    int            iDots, iChars, iDigits;
X    int            iType;
X    LVAL        pXElt;
X    float        fVal;
X    int            iVal;
X
X    iErr = VEOS_SUCCESS;
X    iType = FREE;
X    iDigits = iDots = iChars = 0;
X
X    xlsave1(pXElt);
X
X    pFinger = sData;
X
X    /** minus not necessarily a character **/
X
X    if (pFinger[0] == '-')
X    pFinger ++;
X
X
X    while (TRUE) {
X
X    if (pFinger[0] == ' ' || pFinger[0] == '\0') {
X        break;
X        }
X
X    if (isdigit(pFinger[0]))
X        iDigits ++;
X    else if (pFinger[0] == '.')
X        iDots ++;
X    else
X        iChars ++;
X
X    pFinger ++;
X    }
X
X    cSave = pFinger[0];
X    pFinger[0] = '\0';
X
X    if (iChars > 0 || iDots > 1)
X    pXElt = cvstring(sData);
X
X    else {
X    if (iDots == 0) {
X        sscanf(sData, "%d", &iVal);
X        pXElt = cvfixnum(iVal);
X        }
X    else {
X        sscanf(sData, "%f", &fVal);
X        pXElt = cvflonum(fVal);
X        }
X    }
X
X    pFinger[0] = cSave;
X
X    *hXElt = pXElt;
X
X    xlpop();
X
X    return(iErr);
X
X    } /* StrToXElt */
X/****************************************************************************************/
X
X
X
X/****************************************************************************************/
XLVAL ReverseList(pList)
X    LVAL    pList;
X{
X    LVAL    pSave, pXElt;
X
X    xlsave1(pSave);
X    xlsave1(pXElt);
X
X    while (!null(pList)) {
X    pSave = cdr(pList);
X    rplacd(pList, pXElt);
X    pXElt = pList;
X    pList = pSave;
X    }
X
X    xlpopn(2);
X
X    return(pXElt);
X
X    } /* Native_ReverseList */
X/****************************************************************************************/
X
X
X
X/****************************************************************************************/
Xboolean    IsQuatElt(pXElt)
X    LVAL    pXElt;
X{
X    return(vectorp(pXElt) &&
X       getsz(pXElt) == 2 &&
X       floatp(getelement(pXElt, 0)) &&
X       IsTripleElt(getelement(pXElt, 1)));
X
X    } /* IsQuatElt */
X/****************************************************************************************/
X
X
X/****************************************************************************************/
Xboolean    IsMatrixElt(pXElt)
X    LVAL    pXElt;
X{
X    return(vectorp(pXElt) && getsz(pXElt) == 16);
X
X    } /* IsMatrixElt */
X/****************************************************************************************/
X
X
X/****************************************************************************************/
Xvoid XVect2Mat(pXElt, pMat)
X    LVAL    pXElt;
X    TMatrix    pMat;
X{
X    int        iEltIndex;
X
X    /** assume sanity is checked **/
X    for (iEltIndex = 0; iEltIndex < 16; iEltIndex ++)
X    pMat[iEltIndex / 4][iEltIndex % 4] = getflonum(getelement(pXElt, iEltIndex));
X
X    } /* XVect2Mat */
X/****************************************************************************************/
X
X
X/****************************************************************************************/
XLVAL Mat2XVect(pMat)
X    TMatrix    pMat;
X{
X    LVAL    pXElt;
X    int        iEltIndex;
X
X    xlsave1(pXElt);
X
X    /** assume sanity is checked **/
X    pXElt = newvector(16);
X
X    for (iEltIndex = 0; iEltIndex < 16; iEltIndex ++)
X    setelement(pXElt, iEltIndex, cvflonum(pMat[iEltIndex / 4][iEltIndex % 4]));
X
X    xlpop();
X
X    return(pXElt);
X
X    } /* Mat2XVect */
X/****************************************************************************************/
X
X
X/****************************************************************************************/
Xboolean    IsTripleElt(pXElt)
X    LVAL    pXElt;
X{
X    return(vectorp(pXElt) && getsz(pXElt) == 3);
X
X    } /* IsTripleElt */
X/****************************************************************************************/
X
X
X/****************************************************************************************/
Xvoid XVect2Tri(pXElt, pTri)
X    LVAL    pXElt;
X    TTriple    pTri;
X{
X    /** assume sanity is checked **/
X
X    pTri[0] = getflonum(getelement(pXElt, 0));
X    pTri[1] = getflonum(getelement(pXElt, 1));
X    pTri[2] = getflonum(getelement(pXElt, 2));
X
X    } /* XVect2Tri */
X/****************************************************************************************/
X
X
X/****************************************************************************************/
XLVAL Tri2XVect(pTri)
X    TTriple    pTri;
X{
X    LVAL    pXElt;
X
X    xlsave1(pXElt);
X
X    /** assume sanity is checked **/
X    pXElt = newvector(3);
X
X    setelement(pXElt, 0, cvflonum(pTri[0]));
X    setelement(pXElt, 1, cvflonum(pTri[1]));
X    setelement(pXElt, 2, cvflonum(pTri[2]));
X
X    xlpop();
X
X    return(pXElt);
X
X    } /* Tri2XVect */
X/****************************************************************************************/
X
X
X/****************************************************************************************/
Xvoid XVect2Quat(pXElt, pVect)
X    LVAL    pXElt;
X    TVector    pVect;
X{
X    LVAL    pTri;
X
X    /** assume sanity is checked **/
X
X    pVect[0] = getflonum(getelement(pXElt, 0));
X
X    pTri = getelement(pXElt, 1);
X    pVect[1] = getflonum(getelement(pTri, 0));
X    pVect[2] = getflonum(getelement(pTri, 1));
X    pVect[3] = getflonum(getelement(pTri, 2));
X
X    } /* XVect2Quat */
X/****************************************************************************************/
X
X
X/****************************************************************************************/
XLVAL Quat2XVect(pVect)
X    TVector    pVect;
X{
X    LVAL    pXElt, pMid;
X
X    /** assume sanity is checked **/
X
X    xlsave1(pXElt);
X    xlsave1(pMid);
X
X    pMid = newvector(3);
X
X    setelement(pMid, 0, cvflonum(pVect[1]));
X    setelement(pMid, 1, cvflonum(pVect[2]));
X    setelement(pMid, 2, cvflonum(pVect[3]));
X
X    pXElt = newvector(2);
X
X    setelement(pXElt, 0, cvflonum(pVect[0]));
X    setelement(pXElt, 1, pMid);
X
X    xlpopn(2);
X
X    return(pXElt);
X
X    } /* Quat2XVect */
X/****************************************************************************************/
X
X
X
X/****************************************************************************************/
Xvoid
XLispMat2Mat(lMat, pMat)
X    LVAL    lMat;
X    float    pMat[4][4];
X{
X    pMat[0][0] = getflonum(getelement(lMat, 0));
X    pMat[0][1] = getflonum(getelement(lMat, 1));
X    pMat[0][2] = getflonum(getelement(lMat, 2));
X    pMat[0][3] = getflonum(getelement(lMat, 3));
X
X    pMat[1][0] = getflonum(getelement(lMat, 4));
X    pMat[1][1] = getflonum(getelement(lMat, 5));
X    pMat[1][2] = getflonum(getelement(lMat, 6));
X    pMat[1][3] = getflonum(getelement(lMat, 7));
X
X    pMat[2][0] = getflonum(getelement(lMat, 8));
X    pMat[2][1] = getflonum(getelement(lMat, 9));
X    pMat[2][2] = getflonum(getelement(lMat, 10));
X    pMat[2][3] = getflonum(getelement(lMat, 11));
X
X    pMat[3][0] = getflonum(getelement(lMat, 12));
X    pMat[3][1] = getflonum(getelement(lMat, 13));
X    pMat[3][2] = getflonum(getelement(lMat, 14));
X    pMat[3][3] = getflonum(getelement(lMat, 15));
X
X
X    }/*LispMat2Mat*/
X/****************************************************************************************/
X
X
X/****************************************************************************************/
Xvoid
XMat2LispMat(pMat, lMat)
X     float    pMat[4][4];
X     LVAL    lMat;
X{
X
X    stuff_flonum(lMat, 0,     pMat[0][0]);
X    stuff_flonum(lMat, 1,     pMat[0][1]);
X    stuff_flonum(lMat, 2,     pMat[0][2]);
X    stuff_flonum(lMat, 3,     pMat[0][3]);
X
X    stuff_flonum(lMat, 4,     pMat[1][0]);
X    stuff_flonum(lMat, 5,     pMat[1][1]);
X    stuff_flonum(lMat, 6,     pMat[1][2]);
X    stuff_flonum(lMat, 7,     pMat[1][3]);
X
X    stuff_flonum(lMat, 8,     pMat[2][0]);
X    stuff_flonum(lMat, 9,     pMat[2][1]);
X    stuff_flonum(lMat, 10,     pMat[2][2]);
X    stuff_flonum(lMat, 11,     pMat[2][3]);
X
X    stuff_flonum(lMat, 12,     pMat[3][0]);
X    stuff_flonum(lMat, 13,     pMat[3][1]);
X    stuff_flonum(lMat, 14,     pMat[3][2]);
X    stuff_flonum(lMat, 15,     pMat[3][3]);
X
X    }/*Mat2LispMat*/
X/****************************************************************************************/
X
END_OF_FILE
if test 13040 -ne `wc -c <'src/utils/xv_utils.c'`; then
    echo shar: \"'src/utils/xv_utils.c'\" unpacked with wrong size!
fi
# end of 'src/utils/xv_utils.c'
fi
if test -f 'src/xlisp/xcore/c/unixstuff.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'src/xlisp/xcore/c/unixstuff.c'\"
else
echo shar: Extracting \"'src/xlisp/xcore/c/unixstuff.c'\" \(14087 characters\)
sed "s/^X//" >'src/xlisp/xcore/c/unixstuff.c' <<'END_OF_FILE'
X/* -*-C-*-
X********************************************************************************
X*
X* File:         unixstuff.c
X* RCS:          $Header: unixstuff.c,v 1.3 89/11/25 05:12:16 mayer Exp $
X* Description:  UNIX-Specific interfaces for XLISP
X* Author:       David Michael Betz; Niels Mayer
X* Created:
X* Modified:     Sat Nov 25 05:12:04 1989 (Niels Mayer) mayer@hplnpm
X* Language:     C
X* Package:      N/A
X* Status:       X11r4 contrib tape release
X*
X* WINTERP 1.0 Copyright 1989 Hewlett-Packard Company (by Niels Mayer).
X* XLISP version 2.1, Copyright (c) 1989, by David Betz.
X*
X* Permission to use, copy, modify, distribute, and sell this software and its
X* documentation for any purpose is hereby granted without fee, provided that
X* the above copyright notice appear in all copies and that both that
X* copyright notice and this permission notice appear in supporting
X* documentation, and that the name of Hewlett-Packard and David Betz not be
X* used in advertising or publicity pertaining to distribution of the software
X* without specific, written prior permission.  Hewlett-Packard and David Betz
X* make no representations about the suitability of this software for any
X* purpose. It is provided "as is" without express or implied warranty.
X*
X* HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS
X* SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS,
X* IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL,
X* INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
X* LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
X* OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
X* PERFORMANCE OF THIS SOFTWARE.
X*
X* See ./winterp/COPYRIGHT for information on contacting the authors.
X*
X* Please send modifications, improvements and bugfixes to [e-mail]
X* Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x
X*
X********************************************************************************
X*/
Xstatic char rcs_identity[] = "@(#)$Header: unixstuff.c,v 1.3 89/11/25 05:12:16 mayer Exp $";
X
X
X#include "xlisp.h"
X
X/******************************************************************************
X * Prim_POPEN - start a process and open a pipe for read/write
X * (code stolen from xlfio.c:xopen())
X *
X * syntax: (popen <command line> :direction <direction>)
X *                <command line> is a string to be sent to the subshell (sh).
X *                <direction> is either :input (to read from the pipe) or
X *                                      :output (to write to the pipe).
X *                                      (:input is the default)
X *
X * Popen returns a stream, or NIL if files or processes couldn't be created.
X * The  success  of  the  command  execution  can be checked by examining the
X * return value of pclose.
X *
X * Added to XLISP by Niels Mayer
X ******************************************************************************/
XLVAL Prim_POPEN()
X{
X  extern LVAL k_direction, k_input, k_output;
X  char *name,*mode;
X  FILE *fp;
X  LVAL dir;
X
X  /* get the process name and direction */
X  name = (char *) getstring(xlgastring());
X  if (!xlgetkeyarg(k_direction, &dir))
X    dir = k_input;
X
X  /* get the mode */
X  if (dir == k_input)
X    mode = "r";
X  else if (dir == k_output)
X    mode = "w";
X  else
X    xlerror("bad direction",dir);
X
X  /* try to open the file */
X  return ((fp = popen(name,mode)) ? cvfile(fp) : NIL);
X}
X
X
X/******************************************************************************
X * Prim_PCLOSE - close a pipe opened by Prim_POPEN().
X * (code stolen from xlfio.c:xclose())
X *
X * syntax: (pclose <stream>)
X *                  <stream> is a stream created by popen.
X * returns T if the command executed successfully, otherwise,
X * returns the exit status of the opened command.
X *
X * Added to XLISP by Niels Mayer
X ******************************************************************************/
XLVAL Prim_PCLOSE()
X{
X  extern LVAL true;
X  LVAL fptr;
X  int  result;
X
X  /* get file pointer */
X  fptr = xlgastream();
X  xllastarg();
X
X  /* make sure the file exists */
X  if (getfile(fptr) == NULL)
X    xlfail("file not open");
X
X  /* close the pipe */
X  result = pclose(getfile(fptr));
X
X  if (result == -1)
X    xlfail("<stream> has not been opened with popen");
X
X  setfile(fptr,NULL);
X
X  /* return T if success (exit status 0), else return exit status */
X  return (result ? cvfixnum(result) : true);
X}
X
X
X/******************************************************************************
X * Prim_SYSTEM - run a process, sending output (if any) to stdout/stderr
X *
X * syntax: (system <command line>)
X *                 <command line> is a string to be sent to the subshell (sh).
X *
X * Returns T if the command executed succesfully, otherwise returns the
X * integer shell exit status for the command.
X *
X * Added to XLISP by Niels Mayer
X ******************************************************************************/
XLVAL Prim_SYSTEM()
X{
X  extern LVAL true;
X  extern int sys_nerr;
X  extern char *sys_errlist[];
X  extern int errno;
X  LVAL command;
X  int  result;
X  char temptext[1024];
X
X  /* get shell command */
X  command = xlgastring();
X  xllastarg();
X
X  /* run the process */
X  result = system((char *) getstring(command));
X
X  if (result == -1) {        /* if a system error has occured */
X    if (errno < sys_nerr)
X      (void) sprintf(temptext, "Error in system(3S): %s\n", sys_errlist[errno]);
X    else
X      (void) strcpy(temptext, "Error in system(3S): unknown error\n");
X    xlfail(temptext);
X  }
X
X  /* return T if success (exit status 0), else return exit status */
X  return (result ? cvfixnum(result) : true);
X}
X
X
X/******************************************************************************
X * (FSCANF-FIXNUM <stream> <scanf-format>)
X * This routine calls fscanf(3s) on a <stream> that was previously openend
X * via open or popen. It will not work on an USTREAM.
X * <scanf-format> is a format string containing a single conversion
X * directive that will result in an integer valued conversion.
X * %d, %u, %o, %x, %ld, %lu, %lo and %lx style conversions
X * are acceptable for this routine.
X * WARNING: specifying a <scanf-format> that will result in the conversion
X * of a result larger than sizeof(long) will result in corrupted memory and
X * core dumps.
X *
X * This routine will return an FIXNUM if fscanf() returns 1 (i.e. if
X * the one expected conversion has succeeded. It will return NIL if the
X * conversion wasn't successful, or if EOF was reached.
X ******************************************************************************/
XLVAL Prim_FSCANF_FIXNUM()
X{
X  LVAL  lval_stream;
X  char* fmt;
X  long  result;
X
X  lval_stream = xlgastream();
X  if (getfile(lval_stream) == NULL)
X    xlerror("File not opened.", lval_stream);
X  fmt = (char *) getstring(xlgastring());
X  xllastarg();
X
X  result = 0L;            /* clear it out hibits incase short is written */
X  /* if scanf returns result <1 then an error or eof occured. */
X  if (fscanf(getfile(lval_stream), fmt, &result) < 1)
X    return (NIL);
X  else
X    return (cvfixnum((FIXTYPE) result));
X}
X
X
X/******************************************************************************
X * (FSCANF-STRING <stream> <scanf-format>)
X * This routine calls fscanf(3s) on a <stream> that was previously openend
X * via open or popen. It will not work on an USTREAM.
X * <scanf-format> is a format string containing a single conversion
X * directive that will result in a string valued conversion.
X * %s, %c, and %[...] style conversions are acceptable for
X * this routine.
X * WARNING: specifying a <scanf-format> that will result in the conversion
X * of a result larger than 1024 characters will result in corrupted
X * memory and core dumps.
X *
X * This routine will return a string if fscanf() returns 1 (i.e. if
X * the one expected conversion has succeeded. It will return NIL if the
X * conversion wasn't successful, or if EOF was reached.
X ******************************************************************************/
XLVAL Prim_FSCANF_STRING()
X{
X  LVAL lval_stream;
X  char* fmt;
X  char result[BUFSIZ];
X
X
X  lval_stream = xlgastream();
X  if (getfile(lval_stream) == NULL)
X    xlerror("File not opened.", lval_stream);
X  fmt = (char *) getstring(xlgastring());
X  xllastarg();
X
X  result[0] = result[1] = '\0';    /* if the conversion is %c, then fscanf
X                   doesn't null terminate the string,
X                   so do it just incase */
X
X  /* if scanf returns result <1 then an error or eof occured. */
X  if (fscanf(getfile(lval_stream), fmt, result) < 1)
X    return (NIL);
X  else
X    return (cvstring(result));
X}
X
X
X/******************************************************************************
X * (FSCANF-FLONUM <stream> <scanf-format>)
X * This routine calls fscanf(3s) on a <stream> that was previously openend
X * via open or popen. It will not work on an USTREAM.
X * <scanf-format> is a format string containing a single conversion
X * directive that will result in an FLONUM valued conversion.
X * %e %f or %g are valid conversion specifiers for this routine.
X *
X * WARNING: specifying a <scanf-format> that will result in the conversion
X * of a result larger than sizeof(float) will result in corrupted memory and
X * core dumps.
X *
X * This routine will return a FLONUM if fscanf() returns 1 (i.e. if
X * the one expected conversion has succeeded. It will return NIL if the
X * conversion wasn't successful, or if EOF was reached.
X ******************************************************************************/
XLVAL Prim_FSCANF_FLONUM()
X{
X  LVAL lval_stream;
X  char* fmt;
X  FILE * fp;
X  float result;
X
X  lval_stream = xlgastream();
X  if (getfile(lval_stream) == NULL)
X    xlerror("File not opened.", lval_stream);
X  fmt = (char *) getstring(xlgastring());
X  xllastarg();
X
X  /* if scanf returns result <1 then an error or eof occured. */
X  if (fscanf(getfile(lval_stream), fmt, &result) < 1)
X    return (NIL);
X  else
X    return (cvflonum((FLOTYPE) result));
X}
X
X
X/******************************************************************************/
X/******************************************************************************/
X/******************************************************************************/
X/* -- stuff.c  -- operating system specific routines */
X/* -- Written by dbetz for XLISP 2.0 */
X/* -- Copied by EFJohnson from a BIX message */
X/* -- Unix System V */
X
X#define    LBSIZE    200
X
X/* -- external variables */
Xextern    FILE    *tfp;
X
X/* -- local variables */
Xstatic    long    rseed = 1L;
X
Xstatic    char    lbuf[LBSIZE];
Xstatic    int    lindex;
Xstatic    int    lcount;
X
X
X/* -- osinit - initialize */
Xosinit(banner)
Xchar    *banner;
X{
X    printf("%s\n", banner );
X    lindex    = 0;
X    lcount    = 0;
X}
X
X/* -- osfinish - clean up before returning to the operating system */
Xosfinish()
X{
X}
X
X
X/* -- xoserror - print an error message */
Xxoserror(msg)
X
Xchar    *msg;
X
X{
X    printf( "error: %s\n", msg );
X}
X
X
X/* -- osrand - return a random number between 0 and n-1 */
Xint osrand(n)
X
Xint    n;
X
X{
X    long k1;
X
X    /* -- make sure we don't get stuck at zero */
X    if ( rseed == 0L ) rseed = 1L;
X
X    /* -- algorithm taken from Dr Dobbs Journal, Nov. 1985, page 91 */
X    k1 = rseed / 127773L;
X    if ( ( rseed = 16807L * (rseed - k1 * 127773L) -k1 * 2836L) < 0L )
X        rseed += 2147483647L;
X
X    /* -- return a random number between 0 and n-1 */
X    return( (int) (rseed % (long) n ) );
X}
X
X
X
X/* -- osaopen -- open an ascii file */
XFILE    *osaopen( name, mode )
Xchar    *name, *mode;
X{
X    return( fopen( name, mode ) );
X}
X
X
X
X/* -- osbopen -- open a binary file */
XFILE    *osbopen( name, mode )
Xchar    *name, *mode;
X{
X    return( fopen( name, mode ) );
X}
X
X
X/* -- osclose -- close a file */
Xint    osclose( fp )
XFILE    *fp;
X{
X    return( fclose( fp ) );
X}
X
X
X/* -- osagetc - get a character from an ASCII file */
Xint    osagetc( fp )
XFILE    *fp;
X{
X    return( getc(fp) );
X}
X
X/* -- osaputc - put a character to an ASCII file */
Xint    osaputc( ch, fp )
Xint    ch;
XFILE    *fp;
X{
X    return( putc( ch, fp ) );
X}
X
X
X
X/* -- osbgetc - get a character from a binary file */
Xint    osbgetc( fp )
XFILE    *fp;
X{
X    return( getc(fp) );
X}
X
X/* -- osbputc - put a character to a binary file */
Xint    osbputc( ch, fp )
Xint    ch;
XFILE    *fp;
X{
X    return( putc( ch, fp ) );
X}
X
X
X/* -- ostgetc - get a character from the terminal */
Xint    ostgetc()
X{
X    while(--lcount < 0 )
X        {
X        if ( fgets(lbuf,LBSIZE,stdin) == NULL )
X            return( EOF );
X        if ( tfp )
X            fputs( lbuf, tfp );
X        lcount = strlen( lbuf );
X        lindex = 0;
X        }
X
X    return( lbuf[lindex++] );
X}
X
X
X/* -- ostputc - put a character to the terminal */
Xostputc( ch )
Xint    ch;
X{
X    /* -- check for control characters */
X    oscheck();
X
X    /* -- output the character */
X    putchar( ch );
X
X    /* -- output the char to the transcript file */
X    if ( tfp )
X        osaputc( ch, tfp );
X}
X
X
X
X
X/* -- osflush - flush the terminal input buffer */
Xosflush()
X{
X    lindex = lcount = 0;
X}
X
X
X/* -- oscheck - check for control characters during execution */
Xoscheck()
X{
X}
X
X
X/* -- ossymbols - enter os-specific symbols */
Xossymbols()
X{
X}
X
X/******************************************************************************
X * xosgetenv - get string from environment
X *
X * syntax: (getenv key)
X *                <key> is something like TERM to look up in the unix environment.
X *
X * If "<key>=<val> is not found in the environment, xosgetenv returns NIL.
X * Otherwise, xosgetenv returns a list of strings, one for each ':'-delimited
X * component of <val>.
X *
X * Added to XLISP by Jeff Prothero
X ******************************************************************************/
XLVAL envget( key_as_asciz )
Xchar*        key_as_asciz;
X{
X    extern char* getenv();
X    LVAL result;
X    char *val_as_asciz = getenv( key_as_asciz );
X    xlsave1( result );
X    if (val_as_asciz != NULL) {
X    do {
X        char buf[ 1024 ];
X            char *dst = buf;
X        while (*val_as_asciz   &&   *val_as_asciz != ':') {
X        *dst++ = *val_as_asciz++;
X        }
X        *dst = '\0';
X        result = cons( cvstring(buf), result );
X    } while (*val_as_asciz++);
X    }
X    xlpop();
X    return result;
X}
XLVAL xosenvget()
X{
X    char *key_as_asciz = (char *) getstring(xlgastring());
X    xllastarg();
X    return envget( key_as_asciz );
X}
END_OF_FILE
if test 14087 -ne `wc -c <'src/xlisp/xcore/c/unixstuff.c'`; then
    echo shar: \"'src/xlisp/xcore/c/unixstuff.c'\" unpacked with wrong size!
fi
# end of 'src/xlisp/xcore/c/unixstuff.c'
fi
if test -f 'src/xlisp/xcore/c/xlfio.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'src/xlisp/xcore/c/xlfio.c'\"
else
echo shar: Extracting \"'src/xlisp/xcore/c/xlfio.c'\" \(11944 characters\)
sed "s/^X//" >'src/xlisp/xcore/c/xlfio.c' <<'END_OF_FILE'
X/* -*-C-*-
X********************************************************************************
X*
X* File:         xlfio.c
X* RCS:          $Header: xlfio.c,v 1.4 89/11/25 05:24:44 mayer Exp $
X* Description:  xlisp file i/o
X* Author:       David Michael Betz
X* Created:
X* Modified:     Sat Nov 25 05:24:25 1989 (Niels Mayer) mayer@hplnpm
X* Language:     C
X* Package:      N/A
X* Status:       X11r4 contrib tape release
X*
X* WINTERP 1.0 Copyright 1989 Hewlett-Packard Company (by Niels Mayer).
X* XLISP version 2.1, Copyright (c) 1989, by David Betz.
X*
X* Permission to use, copy, modify, distribute, and sell this software and its
X* documentation for any purpose is hereby granted without fee, provided that
X* the above copyright notice appear in all copies and that both that
X* copyright notice and this permission notice appear in supporting
X* documentation, and that the name of Hewlett-Packard and David Betz not be
X* used in advertising or publicity pertaining to distribution of the software
X* without specific, written prior permission.  Hewlett-Packard and David Betz
X* make no representations about the suitability of this software for any
X* purpose. It is provided "as is" without express or implied warranty.
X*
X* HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS
X* SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS,
X* IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL,
X* INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
X* LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
X* OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
X* PERFORMANCE OF THIS SOFTWARE.
X*
X* See ./winterp/COPYRIGHT for information on contacting the authors.
X*
X* Please send modifications, improvements and bugfixes to [e-mail]
X* Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x
X*
X********************************************************************************
X*/
Xstatic char rcs_identity[] = "@(#)$Header: xlfio.c,v 1.4 89/11/25 05:24:44 mayer Exp $";
X
X#include "xlisp.h"
X
X/* external variables */
Xextern LVAL k_direction,k_input,k_output;
Xextern LVAL s_stdin,s_stdout,s_stderr,true;
Xextern unsigned char buf[];
Xextern int xlfsize;
X
X/* external routines */
Xextern FILE *osaopen();
X
X/* forward declarations */
XFORWARD LVAL getstroutput();
XFORWARD LVAL printit();
XFORWARD LVAL flatsize();
XFORWARD LVAL openit();
X
X/* xread - read an expression */
XLVAL xread()
X{
X    LVAL fptr,eof,rflag,val;
X
X    /* get file pointer and eof value */
X    fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
X    eof = (moreargs() ? xlgetarg() : NIL);
X    rflag = (moreargs() ? xlgetarg() : NIL);
X    xllastarg();
X
X    /* read an expression */
X    if (!xlread(fptr,&val,rflag != NIL))
X    val = eof;
X
X    /* return the expression */
X    return (val);
X}
X
X/* xprint - built-in function 'print' */
XLVAL xprint()
X{
X    return (printit(TRUE,TRUE));
X}
X
X/* xprin1 - built-in function 'prin1' */
XLVAL xprin1()
X{
X    return (printit(TRUE,FALSE));
X}
X
X/* xprinc - built-in function princ */
XLVAL xprinc()
X{
X    return (printit(FALSE,FALSE));
X}
X
X/* xterpri - terminate the current print line */
XLVAL xterpri()
X{
X    LVAL fptr;
X
X    /* get file pointer */
X    fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
X    xllastarg();
X
X    /* terminate the print line and return nil */
X    xlterpri(fptr);
X    return (NIL);
X}
X
X/* printit - common print function */
XLOCAL LVAL printit(pflag,tflag)
X  int pflag,tflag;
X{
X    LVAL fptr,val;
X
X    /* get expression to print and file pointer */
X    val = xlgetarg();
X    fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
X    xllastarg();
X
X    /* print the value */
X    xlprint(fptr,val,pflag);
X
X    /* terminate the print line if necessary */
X    if (tflag)
X    xlterpri(fptr);
X
X    /* return the result */
X    return (val);
X}
X
X/* xflatsize - compute the size of a printed representation using prin1 */
XLVAL xflatsize()
X{
X    return (flatsize(TRUE));
X}
X
X/* xflatc - compute the size of a printed representation using princ */
XLVAL xflatc()
X{
X    return (flatsize(FALSE));
X}
X
X/* flatsize - compute the size of a printed expression */
XLOCAL LVAL flatsize(pflag)
X  int pflag;
X{
X    LVAL val;
X
X    /* get the expression */
X    val = xlgetarg();
X    xllastarg();
X
X    /* print the value to compute its size */
X    xlfsize = 0;
X    xlprint(NIL,val,pflag);
X
X    /* return the length of the expression */
X    return (cvfixnum((FIXTYPE)xlfsize));
X}
X
X/* xopen - open a file */
XLVAL xopen()
X{
X    char *name,*mode;
X    FILE *fp;
X    LVAL dir;
X
X    /* get the file name and direction */
X    name = (char *)getstring(xlgetfname());
X    if (!xlgetkeyarg(k_direction,&dir))
X    dir = k_input;
X
X    /* get the mode */
X    if (dir == k_input)
X    mode = "r";
X    else if (dir == k_output)
X    mode = "w";
X    else
X    xlerror("bad direction",dir);
X
X    /* try to open the file */
X    return ((fp = osaopen(name,mode)) ? cvfile(fp) : NIL);
X}
X
X/* xclose - close a file */
XLVAL xclose()
X{
X    LVAL fptr;
X
X    /* get file pointer */
X    fptr = xlgastream();
X    xllastarg();
X
X    /* make sure the file exists */
X    if (getfile(fptr) == NULL)
X    xlfail("file not open");
X
X    /* close the file */
X    osclose(getfile(fptr));
X    setfile(fptr,NULL);
X
X    /* return nil */
X    return (NIL);
X}
X
X/* xrdchar - read a character from a file */
XLVAL xrdchar()
X{
X    LVAL fptr;
X    int ch;
X
X    /* get file pointer */
X    fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
X    xllastarg();
X
X    /* get character and check for eof */
X    return ((ch = xlgetc(fptr)) == EOF ? NIL : cvchar(ch));
X}
X
X/* xrdbyte - read a byte from a file */
XLVAL xrdbyte()
X{
X    LVAL fptr;
X    int ch;
X
X    /* get file pointer */
X    fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
X    xllastarg();
X
X    /* get character and check for eof */
X    return ((ch = xlgetc(fptr)) == EOF ? NIL : cvfixnum((FIXTYPE)ch));
X}
X
X/* xpkchar - peek at a character from a file */
XLVAL xpkchar()
X{
X    LVAL flag,fptr;
X    int ch;
X
X    /* peek flag and get file pointer */
X    flag = (moreargs() ? xlgetarg() : NIL);
X    fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
X    xllastarg();
X
X    /* skip leading white space and get a character */
X    if (flag)
X    while ((ch = xlpeek(fptr)) != EOF && isspace(ch))
X        xlgetc(fptr);
X    else
X    ch = xlpeek(fptr);
X
X    /* return the character */
X    return (ch == EOF ? NIL : cvchar(ch));
X}
X
X/* xwrchar - write a character to a file */
XLVAL xwrchar()
X{
X    LVAL fptr,chr;
X
X    /* get the character and file pointer */
X    chr = xlgachar();
X    fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
X    xllastarg();
X
X    /* put character to the file */
X    xlputc(fptr,getchcode(chr));
X
X    /* return the character */
X    return (chr);
X}
X
X/* xwrbyte - write a byte to a file */
XLVAL xwrbyte()
X{
X    LVAL fptr,chr;
X
X    /* get the byte and file pointer */
X    chr = xlgafixnum();
X    fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
X    xllastarg();
X
X    /* put byte to the file */
X    xlputc(fptr,(int)getfixnum(chr));
X
X    /* return the character */
X    return (chr);
X}
X
X/* xreadline - read a line from a file */
XLVAL xreadline()
X{
X    unsigned char buf[STRMAX+1],*p,*sptr;
X    LVAL fptr,str,newstr;
X    int len,blen,ch;
X
X    /* protect some pointers */
X    xlsave1(str);
X
X    /* get file pointer */
X    fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
X    xllastarg();
X
X    /* get character and check for eof */
X    len = blen = 0; p = buf;
X    while ((ch = xlgetc(fptr)) != EOF && ch != '\n') {
X
X    /* check for buffer overflow */
X    if (blen >= STRMAX) {
X         newstr = newstring(len + STRMAX + 1);
X        sptr = getstring(newstr); *sptr = '\0';
X        if (str) strcat(sptr,getstring(str));
X        *p = '\0'; strcat(sptr,buf);
X        p = buf; blen = 0;
X        len += STRMAX;
X        str = newstr;
X    }
X
X    /* store the character */
X    *p++ = ch; ++blen;
X    }
X
X    /* check for end of file */
X    if (len == 0 && p == buf && ch == EOF) {
X    xlpop();
X    return (NIL);
X    }
X
X    /* append the last substring */
X    if (str == NIL || blen) {
X    newstr = newstring(len + blen + 1);
X    sptr = getstring(newstr); *sptr = '\0';
X    if (str) strcat(sptr,getstring(str));
X    *p = '\0'; strcat(sptr,buf);
X    str = newstr;
X    }
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the string */
X    return (str);
X}
X
X
X/* xmkstrinput - make a string input stream */
XLVAL xmkstrinput()
X{
X    int start,end,len,i;
X    unsigned char *str;
X    LVAL string,val;
X
X    /* protect the return value */
X    xlsave1(val);
X
X    /* get the string and length */
X    string = xlgastring();
X    str = getstring(string);
X    len = getslength(string) - 1;
X
X    /* get the starting offset */
X    if (moreargs()) {
X    val = xlgafixnum();
X    start = (int)getfixnum(val);
X    }
X    else start = 0;
X
X    /* get the ending offset */
X    if (moreargs()) {
X    val = xlgafixnum();
X    end = (int)getfixnum(val);
X    }
X    else end = len;
X    xllastarg();
X
X    /* check the bounds */
X    if (start < 0 || start > len)
X    xlerror("string index out of bounds",cvfixnum((FIXTYPE)start));
X    if (end < 0 || end > len)
X    xlerror("string index out of bounds",cvfixnum((FIXTYPE)end));
X
X    /* make the stream */
X    val = newustream();
X
X    /* copy the substring into the stream */
X    for (i = start; i < end; ++i)
X    xlputc(val,str[i]);
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the new stream */
X    return (val);
X}
X
X/* xmkstroutput - make a string output stream */
XLVAL xmkstroutput()
X{
X    return (newustream());
X}
X
X/* xgetstroutput - get output stream string */
XLVAL xgetstroutput()
X{
X    LVAL stream;
X    stream = xlgaustream();
X    xllastarg();
X    return (getstroutput(stream));
X}
X
X/* xgetlstoutput - get output stream list */
XLVAL xgetlstoutput()
X{
X    LVAL stream,val;
X
X    /* get the stream */
X    stream = xlgaustream();
X    xllastarg();
X
X    /* get the output character list */
X    val = gethead(stream);
X
X    /* empty the character list */
X    sethead(stream,NIL);
X    settail(stream,NIL);
X
X    /* return the list */
X    return (val);
X}
X
X/* xformat - formatted output function */
XLVAL xformat()
X{
X    LVAL fmtstring,stream,val;
X    unsigned char *fmt;
X    int ch;
X
X    /* protect some pointers */
X    xlstkcheck(2);
X    xlsave(fmtstring);
X    xlsave(stream);
X
X    /* get the stream and format string */
X    stream = xlgetarg();
X    if (stream == NIL)
X    val = stream = newustream();
X    else {
X    if (stream == true)
X        stream = getvalue(s_stdout);
X    else if (!streamp(stream) && !ustreamp(stream))
X        xlbadtype(stream);
X    val = NIL;
X    }
X    fmtstring = xlgastring();
X    fmt = getstring(fmtstring);
X
X    /* process the format string */
X    while (ch = *fmt++)
X    if (ch == '~') {
X        switch (*fmt++) {
X        case '\0':
X        xlerror("expecting a format directive",cvstring(fmt-1));
X        case 'a': case 'A':
X        xlprint(stream,xlgetarg(),FALSE);
X        break;
X        case 's': case 'S':
X        xlprint(stream,xlgetarg(),TRUE);
X        break;
X        case '%':
X        xlterpri(stream);
X        break;
X        case '~':
X        xlputc(stream,'~');
X        break;
X        case '\n':
X        while (*fmt && *fmt != '\n' && isspace(*fmt))
X            ++fmt;
X        break;
X        default:
X        xlerror("unknown format directive",cvstring(fmt-1));
X        }
X    }
X    else
X        xlputc(stream,ch);
X
X    /* get the output string for a stream argument of NIL */
X    if (val) val = getstroutput(val);
X    xlpopn(2);
X
X    /* return the value */
X    return (val);
X}
X
X/* getstroutput - get the output stream string (internal) */
XLOCAL LVAL getstroutput(stream)
X  LVAL stream;
X{
X    unsigned char *str;
X    LVAL next,val;
X    int len,ch;
X
X    /* compute the length of the stream */
X    for (len = 0, next = gethead(stream); next != NIL; next = cdr(next))
X    ++len;
X
X    /* create a new string */
X    val = newstring(len + 1);
X
X    /* copy the characters into the new string */
X    str = getstring(val);
X    while ((ch = xlgetc(stream)) != EOF)
X    *str++ = ch;
X    *str = '\0';
X
X    /* return the string */
X    return (val);
X}
X
END_OF_FILE
if test 11944 -ne `wc -c <'src/xlisp/xcore/c/xlfio.c'`; then
    echo shar: \"'src/xlisp/xcore/c/xlfio.c'\" unpacked with wrong size!
fi
# end of 'src/xlisp/xcore/c/xlfio.c'
fi
if test -f 'src/xlisp/xcore/c/xlisp.h' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'src/xlisp/xcore/c/xlisp.h'\"
else
echo shar: Extracting \"'src/xlisp/xcore/c/xlisp.h'\" \(13662 characters\)
sed "s/^X//" >'src/xlisp/xcore/c/xlisp.h' <<'END_OF_FILE'
X/*
X* -*-C-*-
X********************************************************************************
X*
X* File:         xlisp.h
X* RCS:          $Header: xlisp.h,v 1.6 89/12/17 19:05:05 mayer Exp $
X* Description:  libXlisp.a external interfaces
X* Author:       David Michael Betz; Niels Mayer
X* Created:
X* Modified:     Sun Dec 17 04:50:59 1989 (Niels Mayer) mayer@hplnpm
X* Language:     C
X* Package:      N/A
X* Status:       X11r4 contrib tape release
X*
X* WINTERP 1.0 Copyright 1989 Hewlett-Packard Company (by Niels Mayer).
X* XLISP version 2.1, Copyright (c) 1989, by David Betz.
X*
X* Permission to use, copy, modify, distribute, and sell this software and its
X* documentation for any purpose is hereby granted without fee, provided that
X* the above copyright notice appear in all copies and that both that
X* copyright notice and this permission notice appear in supporting
X* documentation, and that the name of Hewlett-Packard and David Betz not be
X* used in advertising or publicity pertaining to distribution of the software
X* without specific, written prior permission.  Hewlett-Packard and David Betz
X* make no representations about the suitability of this software for any
X* purpose. It is provided "as is" without express or implied warranty.
X*
X* HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS
X* SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS,
X* IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL,
X* INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
X* LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
X* OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
X* PERFORMANCE OF THIS SOFTWARE.
X*
X* See ./winterp/COPYRIGHT for information on contacting the authors.
X*
X* Please send modifications, improvements and bugfixes to [e-mail]
X* Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x
X*
X********************************************************************************
X*/
X
X#ifndef __XLISP_H__
X#define __XLISP_H__
X
X#include <stdio.h>
X#include <ctype.h>
X#include <setjmp.h>
X
X/* NNODES    number of nodes to allocate in each request (1000) */
X/* EDEPTH    evaluation stack depth (2000) */
X/* ADEPTH    argument stack depth (1000) */
X/* FORWARD    type of a forward declaration () */
X/* LOCAL    type of a local function (static) */
X/* AFMT        printf format for addresses ("%x") */
X/* FIXTYPE    data type for fixed point numbers (long) */
X/* ITYPE    fixed point input conversion routine type (long atol()) */
X/* ICNV        fixed point input conversion routine (atol) */
X/* IFMT        printf format for fixed point numbers ("%ld") */
X/* FLOTYPE    data type for floating point numbers (float) */
X/* OFFTYPE    number the size of an address (int) */
X
X
X/* for BSD & SYSV Unix. */
X#ifdef UNIX
X#define NNODES        2000
X#define AFMT        "%lx"    /* added by NPM */
X#define OFFTYPE        long    /* added by NPM */
X#define SAVERESTORE
X#endif
X
X/* for Mips C compiler - Silicon Graphhics */
X#ifdef _BSD_COMPAT
X#define LOCAL
X#endif
X
X/* for the Turbo C compiler - MS-DOS, large model */
X#ifdef _TURBOC_
X#define NNODES        2000
X#define AFMT        "%lx"
X#define OFFTYPE        long
X#define SAVERESTORE
X#endif
X
X/* for the AZTEC C compiler - MS-DOS, large model */
X#ifdef AZTEC_LM
X#define NNODES        2000
X#define AFMT        "%lx"
X#define OFFTYPE        long
X#define CVPTR(x)    ptrtoabs(x)
X#define NIL        (void *)0
Xextern long ptrtoabs();
X#define SAVERESTORE
X#endif
X
X/* for the AZTEC C compiler - Macintosh */
X#ifdef AZTEC_MAC
X#define NNODES        2000
X#define AFMT        "%lx"
X#define OFFTYPE        long
X#define NIL        (void *)0
X#define SAVERESTORE
X#endif
X
X/* for the AZTEC C compiler - Amiga */
X#ifdef AZTEC_AMIGA
X#define NNODES        2000
X#define AFMT        "%lx"
X#define OFFTYPE        long
X#define NIL        (void *)0
X#define SAVERESTORE
X#endif
X
X/* for the Lightspeed C compiler - Macintosh */
X#ifdef LSC
X#define NNODES        2000
X#define AFMT        "%lx"
X#define OFFTYPE        long
X#define NIL        (void *)0
X#define SAVERESTORE
X#endif
X
X/* for the Microsoft C compiler - MS-DOS, large model */
X#ifdef MSC
X#define NNODES        2000
X#define AFMT        "%lx"
X#define OFFTYPE        long
X#endif
X
X/* for the Mark Williams C compiler - Atari ST */
X#ifdef MWC
X#define AFMT        "%lx"
X#define OFFTYPE        long
X#endif
X
X/* for the Lattice C compiler - Atari ST */
X#ifdef LATTICE
X#define FIXTYPE        int
X#define ITYPE        int atoi()
X#define ICNV(n)        atoi(n)
X#define IFMT        "%d"
X#endif
X
X/* for the Digital Research C compiler - Atari ST */
X#ifdef DR
X#define LOCAL
X#define AFMT        "%lx"
X#define OFFTYPE        long
X#undef NULL
X#define NULL        0L
X#endif
X
X
X/* default important definitions */
X#ifndef NNODES
X#define NNODES        1000
X#endif
X#ifndef EDEPTH
X#define EDEPTH        2000
X#endif
X#ifndef ADEPTH
X#define ADEPTH        1000
X#endif
X#ifndef FORWARD
X#define FORWARD
X#endif
X#ifndef LOCAL
X#define LOCAL        static
X#endif
X#ifndef AFMT
X#define AFMT        "%x"
X#endif
X#ifndef FIXTYPE
X#define FIXTYPE        long
X#endif
X#ifndef ITYPE
X#define ITYPE        long atol()
X#endif
X#ifndef ICNV
X#define ICNV(n)        atol(n)
X#endif
X#ifndef IFMT
X#define IFMT        "%ld"
X#endif
X#ifndef FLOTYPE
X#define FLOTYPE        double
X#endif
X#ifndef OFFTYPE
X#define OFFTYPE        int
X#endif
X#ifndef CVPTR
X#define CVPTR(x)    (x)
X#endif
X#ifndef UCHAR
X#define UCHAR        unsigned char
X#endif
X
X/* useful definitions */
X#ifndef TRUE
X#define TRUE    (1)
X#endif
X#ifndef FALSE
X#define FALSE    (0)
X#endif
X#ifndef NIL
X#define NIL    (LVAL )0
X#endif
X
X/* instance variable numbers for the class 'Class' */
X#define MESSAGES    0    /* list   of messages */
X#define IVARS        1    /* list   of instance variable names */
X#define CVARS        2    /* list   of class variable names */
X#define CVALS        3    /* vector of class variable values */
X#define SUPERCLASS    4    /* pointer to the superclass */
X#define IVARCNT        5    /* number of class instance variables */
X#define IVARTOTAL    6    /* total number of instance variables */
X/* number of instance variables for the class 'Class' */
X#define CLASSSIZE    7
X
X/* Include PROVIDE_XXX #defines for extension modules. *//* JSP */
X#define MODULE_XLISP_H_PROVIDES
X#include "../../xmodules.h"
X#undef MODULE_XLISP_H_PROVIDES
X
X/* include the dynamic memory definitions */
X#include "xldmem.h"
X
X/* program limits */
X#define STRMAX        100        /* maximum length of a string constant */
X#define HSIZE        199        /* symbol hash table size */
X#define SAMPLE        100        /* control character sample rate */
X
X/* function table offsets for the initialization functions */
X#define FT_RMHASH    0
X#define FT_RMQUOTE    1
X#define FT_RMDQUOTE    2
X#define FT_RMBQUOTE    3
X#define FT_RMCOMMA    4
X#define FT_RMLPAR    5
X#define FT_RMRPAR    6
X#define FT_RMSEMI    7
X/* #define xxxxxx       8 */
X/* #define yyyyyy       9 */
X
X#define FT_CLNEW    10
X#define FT_CLISNEW    11
X#define FT_CLANSWER    12
X#define FT_OBISNEW    13
X#define FT_OBCLASS    14
X#define FT_OBSHOW    15
X
X#define LAST_FUNTAB_POINTER_USED_BY_libXlisp FT_OBSHOW
X
X/* include hybrid function in xlisp symbol table */ /* Voodoo */
X/* use from within user implemented xlinclude_hybrid_prims */
X/* or from within user implemented .h which xmodules.h includes */
X#define DEFINE_SUBR(a,b)   xldefine_prim(a, SUBR, b);
X#define DEFINE_FSUBR(a,b)  xldefine_prim(a, FSUBR, b);
X
X/* macro to push a value onto the argument stack */
X#define pusharg(x)    {if (xlsp >= xlargstktop) xlargstkoverflow();\
X             *xlsp++ = (x);}
X
X/* macros to protect pointers */
X#define xlstkcheck(n)    {if (xlstack - (n) < xlstkbase) xlstkoverflow();}
X#define xlsave(n)    {*--xlstack = &n; n = NIL;}
X#define xlprotect(n)    {*--xlstack = &n;}
X
X/* check the stack and protect a single pointer */
X#define xlsave1(n)    {if (xlstack <= xlstkbase) xlstkoverflow();\
X                         *--xlstack = &n; n = NIL;}
X#define xlprot1(n)    {if (xlstack <= xlstkbase) xlstkoverflow();\
X                         *--xlstack = &n;}
X
X/* macros to pop pointers off the stack */
X#define xlpop()        {++xlstack;}
X#define xlpopn(n)    {xlstack+=(n);}
X
X/* macros to manipulate the lexical environment */
X#define xlframe(e)    cons(NIL,e)
X#define xlbind(s,v)    xlpbind(s,v,xlenv)
X#define xlfbind(s,v)    xlpbind(s,v,xlfenv);
X#define xlpbind(s,v,e)    {rplaca(e,cons(cons(s,v),car(e)));}
X
X/* macros to manipulate the dynamic environment */
X#define xldbind(s,v)    {xldenv = cons(cons(s,getvalue(s)),xldenv);\
X             setvalue(s,v);}
X#define xlunbind(e)    {for (; xldenv != (e); xldenv = cdr(xldenv))\
X               setvalue(car(car(xldenv)),cdr(car(xldenv)));}
X
X/* type predicates */
X#define atom(x)        ((x) == NIL || ntype(x) != CONS)
X#define null(x)        ((x) == NIL)
X#define listp(x)    ((x) == NIL || ntype(x) == CONS)
X#define consp(x)    ((x) && ntype(x) == CONS)
X#define subrp(x)    ((x) && ntype(x) == SUBR)
X#define fsubrp(x)    ((x) && ntype(x) == FSUBR)
X#define stringp(x)    ((x) && ntype(x) == STRING)
X#define symbolp(x)    ((x) && ntype(x) == SYMBOL)
X#define streamp(x)    ((x) && ntype(x) == STREAM)
X
X#define objectp(x)    ((x) && ntype(x) == OBJECT)
X
X#define fixp(x)        ((x) && ntype(x) == FIXNUM)
X#define floatp(x)    ((x) && ntype(x) == FLONUM)
X#define vectorp(x)    ((x) && ntype(x) == VECTOR)
X#define closurep(x)    ((x) && ntype(x) == CLOSURE)
X#define charp(x)    ((x) && ntype(x) == CHAR)
X#define ustreamp(x)    ((x) && ntype(x) == USTREAM)
X#define structp(x)    ((x) && ntype(x) == STRUCT)
X#define boundp(x)    (getvalue(x) != s_unbound)
X#define fboundp(x)    (getfunction(x) != s_unbound)
X
X/* shorthand functions */
X#define consa(x)    cons(x,NIL)
X#define consd(x)    cons(NIL,x)
X
X/* set element of a vector */ /* Voodoo */
X#define stuff_fixnum(arg, ind, val) ((arg)->n_vdata[ind])->n_fixnum = (val)
X#define stuff_flonum(arg, ind, val) ((arg)->n_vdata[ind])->n_flonum = (val)
X
X/* argument list parsing macros */
X#define xlgetarg()    (testarg(nextarg()))
X#define xllastarg()    {if (xlargc != 0) xltoomany();}
X#define testarg(e)    (moreargs() ? (e) : xltoofew())
X#define typearg(tp)    (tp(*xlargv) ? nextarg() : xlbadtype(*xlargv))
X#define nextarg()    (--xlargc, *xlargv++)
X#define moreargs()    (xlargc > 0)
X
X/* macros to get arguments of a particular type */
X#define xlgacons()    (testarg(typearg(consp)))
X#define xlgalist()    (testarg(typearg(listp)))
X#define xlgasymbol()    (testarg(typearg(symbolp)))
X#define xlgastring()    (testarg(typearg(stringp)))
X#define xlgaobject()    (testarg(typearg(objectp)))
X#define xlgafixnum()    (testarg(typearg(fixp)))
X#define xlgaflonum()    (testarg(typearg(floatp)))
X#define xlgachar()    (testarg(typearg(charp)))
X#define xlgavector()    (testarg(typearg(vectorp)))
X#define xlgastream()    (testarg(typearg(streamp)))
X#define xlgaustream()    (testarg(typearg(ustreamp)))
X#define xlgaclosure()    (testarg(typearg(closurep)))
X#define xlgastruct()    (testarg(typearg(structp)))
X
X#ifndef OPTIMAL        /* Voodoo */
X#define xlsetjmp(context)         setjmp(context)
X#define xllongjmp(context, mask)     longjmp(context, mask)
X#else
X#define xlsetjmp(context)         0
X#define xllongjmp(context, mask) \
X{ \
X    xlfatal("can't recover, bye..."); \
X    exit(0); \
X    }
X#endif
X
X/* function definition structure */
Xtypedef struct {
X    char *fd_name;    /* function name */
X    int fd_type;    /* function type */
X    LVAL (*fd_subr)();    /* function entry point */
X} FUNDEF;
X
X/* execution context flags */
X#define CF_GO        0x0001
X#define CF_RETURN    0x0002
X#define CF_THROW    0x0004
X#define CF_ERROR    0x0008
X#define CF_CLEANUP    0x0010
X#define CF_CONTINUE    0x0020
X#define CF_TOPLEVEL    0x0040
X#define CF_BRKLEVEL    0x0080
X#define CF_UNWIND    0x0100
X
X/* execution context */
Xtypedef struct context {
X    int c_flags;            /* context type flags */
X    LVAL c_expr;            /* expression (type dependant) */
X    jmp_buf c_jmpbuf;            /* longjmp context */
X    struct context *c_xlcontext;    /* old value of xlcontext */
X    LVAL **c_xlstack;            /* old value of xlstack */
X    LVAL *c_xlargv;            /* old value of xlargv */
X    int c_xlargc;            /* old value of xlargc */
X    LVAL *c_xlfp;            /* old value of xlfp */
X    LVAL *c_xlsp;            /* old value of xlsp */
X    LVAL c_xlenv;            /* old value of xlenv */
X    LVAL c_xlfenv;            /* old value of xlfenv */
X    LVAL c_xldenv;            /* old value of xldenv */
X} CONTEXT;
X
X/* external variables */
Xextern LVAL **xlstktop;           /* top of the evaluation stack */
Xextern LVAL **xlstkbase;    /* base of the evaluation stack */
Xextern LVAL **xlstack;        /* evaluation stack pointer */
Xextern LVAL *xlargstkbase;    /* base of the argument stack */
Xextern LVAL *xlargstktop;    /* top of the argument stack */
Xextern LVAL *xlfp;        /* argument frame pointer */
Xextern LVAL *xlsp;        /* argument stack pointer */
Xextern LVAL *xlargv;        /* current argument vector */
Xextern int xlargc;        /* current argument count */
X
X/* external procedure declarations */
Xextern LVAL xleval();        /* evaluate an expression */
Xextern LVAL xlapply();        /* apply a function to arguments */
Xextern LVAL xlsubr();        /* enter a subr/fsubr */
Xextern LVAL xlenter();        /* enter a symbol */
Xextern LVAL xlmakesym();    /* make an uninterned symbol */
Xextern LVAL xlgetvalue();    /* get value of a symbol (checked) */
Xextern LVAL xlxgetvalue();    /* get value of a symbol */
Xextern LVAL xlgetfunction();    /* get functional value of a symbol */
Xextern LVAL xlxgetfunction();    /* get functional value of a symbol (checked) */
Xextern LVAL xlexpandmacros();    /* expand macros in a form */
Xextern LVAL xlgetprop();    /* get the value of a property */
Xextern LVAL xlclose();        /* create a function closure */
X
Xextern void xldefine_prim();    /* load xlisp function */ /* Voodoo */
X
X/* argument list parsing functions */
Xextern LVAL xlgetfile();          /* get a file/stream argument */
Xextern LVAL xlgetfname();    /* get a filename argument */
X
X/* error reporting functions (don't *really* return at all) */
Xextern LVAL xltoofew();        /* report "too few arguments" error */
Xextern LVAL xlbadtype();    /* report "bad argument type" error */
X
X
X/* Include hybrid-class functions. *//* JSP */
X/* (Last so you can #undef stuff.) *//* JSP */
X#define MODULE_XLISP_H_GLOBALS
X#include "../../xmodules.h"
X#undef MODULE_XLISP_H_GLOBALS
X
X#endif /* __XLISP_H__ */
END_OF_FILE
if test 13662 -ne `wc -c <'src/xlisp/xcore/c/xlisp.h'`; then
    echo shar: \"'src/xlisp/xcore/c/xlisp.h'\" unpacked with wrong size!
fi
# end of 'src/xlisp/xcore/c/xlisp.h'
fi
if test -f 'src/xlisp/xcore/c/xlmath.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'src/xlisp/xcore/c/xlmath.c'\"
else
echo shar: Extracting \"'src/xlisp/xcore/c/xlmath.c'\" \(11975 characters\)
sed "s/^X//" >'src/xlisp/xcore/c/xlmath.c' <<'END_OF_FILE'
X/* -*-C-*-
X********************************************************************************
X*
X* File:         xlmath.c
X* RCS:          $Header: xlmath.c,v 1.3 89/11/25 05:40:35 mayer Exp $
X* Description:  xlisp built-in arithmetic functions
X* Author:       David Michael Betz
X* Created:
X* Modified:     Sat Nov 25 05:40:27 1989 (Niels Mayer) mayer@hplnpm
X* Language:     C
X* Package:      N/A
X* Status:       X11r4 contrib tape release
X*
X* WINTERP 1.0 Copyright 1989 Hewlett-Packard Company (by Niels Mayer).
X* XLISP version 2.1, Copyright (c) 1989, by David Betz.
X*
X* Permission to use, copy, modify, distribute, and sell this software and its
X* documentation for any purpose is hereby granted without fee, provided that
X* the above copyright notice appear in all copies and that both that
X* copyright notice and this permission notice appear in supporting
X* documentation, and that the name of Hewlett-Packard and David Betz not be
X* used in advertising or publicity pertaining to distribution of the software
X* without specific, written prior permission.  Hewlett-Packard and David Betz
X* make no representations about the suitability of this software for any
X* purpose. It is provided "as is" without express or implied warranty.
X*
X* HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS
X* SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS,
X* IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL,
X* INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
X* LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
X* OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
X* PERFORMANCE OF THIS SOFTWARE.
X*
X* See ./winterp/COPYRIGHT for information on contacting the authors.
X*
X* Please send modifications, improvements and bugfixes to [e-mail]
X* Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x
X*
X********************************************************************************
X*/
Xstatic char rcs_identity[] = "@(#)$Header: xlmath.c,v 1.3 89/11/25 05:40:35 mayer Exp $";
X
X
X#include "xlisp.h"
X#include <math.h>
X
X/* external variables */
Xextern LVAL true;
X
X/* forward declarations */
XFORWARD LVAL unary();
XFORWARD LVAL binary();
XFORWARD LVAL predicate();
XFORWARD LVAL compare();
X
X/* binary functions */
XLVAL xadd()    { return (binary('+')); } /* + */
XLVAL xsub()    { return (binary('-')); } /* - */
XLVAL xmul()    { return (binary('*')); } /* * */
XLVAL xdiv()    { return (binary('/')); } /* / */
XLVAL xrem()    { return (binary('%')); } /* rem */
XLVAL xmin()    { return (binary('m')); } /* min */
XLVAL xmax()    { return (binary('M')); } /* max */
XLVAL xexpt()   { return (binary('E')); } /* expt */
XLVAL xlogand() { return (binary('&')); } /* logand */
XLVAL xlogior() { return (binary('|')); } /* logior */
XLVAL xlogxor() { return (binary('^')); } /* logxor */
X
X/* xgcd - greatest common divisor */
XLVAL xgcd()
X{
X    FIXTYPE m,n,r;
X    LVAL arg;
X
X    if (!moreargs())            /* check for identity case */
X    return (cvfixnum((FIXTYPE)0));
X    arg = xlgafixnum();
X    n = getfixnum(arg);
X    if (n < (FIXTYPE)0) n = -n;        /* absolute value */
X    while (moreargs()) {
X    arg = xlgafixnum();
X    m = getfixnum(arg);
X    if (m < (FIXTYPE)0) m = -m;    /* absolute value */
X    for (;;) {            /* euclid's algorithm */
X        r = m % n;
X        if (r == (FIXTYPE)0)
X        break;
X        m = n;
X        n = r;
X    }
X    }
X    return (cvfixnum(n));
X}
X
X/* binary - handle binary operations */
XLOCAL LVAL binary(fcn)
X  int fcn;
X{
X    FIXTYPE ival,iarg;
X    FLOTYPE fval,farg;
X    LVAL arg;
X    int mode;
X
X    /* get the first argument */
X    arg = xlgetarg();
X
X    /* set the type of the first argument */
X    if (fixp(arg)) {
X    ival = getfixnum(arg);
X    mode = 'I';
X    }
X    else if (floatp(arg)) {
X    fval = getflonum(arg);
X    mode = 'F';
X    }
X    else
X    xlerror("bad argument type",arg);
X
X    /* treat a single argument as a special case */
X    if (!moreargs()) {
X    switch (fcn) {
X    case '-':
X        switch (mode) {
X        case 'I':
X        ival = -ival;
X        break;
X        case 'F':
X        fval = -fval;
X        break;
X        }
X        break;
X    case '/':
X        switch (mode) {
X        case 'I':
X        checkizero(ival);
X        ival = 1 / ival;
X        break;
X        case 'F':
X        checkfzero(fval);
X        fval = 1.0 / fval;
X        break;
X        }
X    }
X    }
X
X    /* handle each remaining argument */
X    while (moreargs()) {
X
X    /* get the next argument */
X    arg = xlgetarg();
X
X    /* check its type */
X    if (fixp(arg)) {
X        switch (mode) {
X        case 'I':
X            iarg = getfixnum(arg);
X            break;
X        case 'F':
X            farg = (FLOTYPE)getfixnum(arg);
X        break;
X        }
X    }
X    else if (floatp(arg)) {
X        switch (mode) {
X        case 'I':
X            fval = (FLOTYPE)ival;
X        farg = getflonum(arg);
X        mode = 'F';
X        break;
X        case 'F':
X            farg = getflonum(arg);
X        break;
X        }
X    }
X    else
X        xlerror("bad argument type",arg);
X
X    /* accumulate the result value */
X    switch (mode) {
X    case 'I':
X        switch (fcn) {
X        case '+':    ival += iarg; break;
X        case '-':    ival -= iarg; break;
X        case '*':    ival *= iarg; break;
X        case '/':    checkizero(iarg); ival /= iarg; break;
X        case '%':    checkizero(iarg); ival %= iarg; break;
X        case 'M':    if (iarg > ival) ival = iarg; break;
X        case 'm':    if (iarg < ival) ival = iarg; break;
X        case '&':    ival &= iarg; break;
X        case '|':    ival |= iarg; break;
X        case '^':    ival ^= iarg; break;
X        default:    badiop();
X        }
X        break;
X    case 'F':
X        switch (fcn) {
X        case '+':    fval += farg; break;
X        case '-':    fval -= farg; break;
X        case '*':    fval *= farg; break;
X        case '/':    checkfzero(farg); fval /= farg; break;
X        case 'M':    if (farg > fval) fval = farg; break;
X        case 'm':    if (farg < fval) fval = farg; break;
X        case 'E':    fval = pow(fval,farg); break;
X        default:    badfop();
X        }
X            break;
X    }
X    }
X
X    /* return the result */
X    switch (mode) {
X    case 'I':    return (cvfixnum(ival));
X    case 'F':    return (cvflonum(fval));
X    }
X}
X
X/* checkizero - check for integer division by zero */
XLOCAL checkizero(iarg)
X  FIXTYPE iarg;
X{
X    if (iarg == 0)
X    xlfail("division by zero");
X}
X
X/* checkfzero - check for floating point division by zero */
XLOCAL checkfzero(farg)
X  FLOTYPE farg;
X{
X    if (farg == 0.0)
X    xlfail("division by zero");
X}
X
X/* checkfneg - check for square root of a negative number */
XLOCAL checkfneg(farg)
X  FLOTYPE farg;
X{
X    if (farg < 0.0)
X    xlfail("square root of a negative number");
X}
X
X/* unary functions */
XLVAL xlognot() { return (unary('~')); } /* lognot */
XLVAL xabs()    { return (unary('A')); } /* abs */
XLVAL xadd1()   { return (unary('+')); } /* 1+ */
XLVAL xsub1()   { return (unary('-')); } /* 1- */
XLVAL xsin()    { return (unary('S')); } /* sin */
XLVAL xcos()    { return (unary('C')); } /* cos */
XLVAL xtan()    { return (unary('T')); } /* tan */
XLVAL xasin()   { return (unary('s')); } /* asin */
XLVAL xacos()   { return (unary('c')); } /* acos */
XLVAL xatan()   { return (unary('t')); } /* atan */
XLVAL xexp()    { return (unary('E')); } /* exp */
XLVAL xsqrt()   { return (unary('R')); } /* sqrt */
XLVAL xfix()    { return (unary('I')); } /* truncate */
XLVAL xfloat()  { return (unary('F')); } /* float */
XLVAL xrand()   { return (unary('?')); } /* random */
X
X/* unary - handle unary operations */
XLOCAL LVAL unary(fcn)
X  int fcn;
X{
X    FLOTYPE fval;
X    FIXTYPE ival;
X    LVAL arg;
X
X    /* get the argument */
X    arg = xlgetarg();
X    xllastarg();
X
X    /* check its type */
X    if (fixp(arg)) {
X    ival = getfixnum(arg);
X    switch (fcn) {
X    case '~':    ival = ~ival; break;
X    case 'A':    ival = (ival < 0 ? -ival : ival); break;
X    case '+':    ival++; break;
X    case '-':    ival--; break;
X    case 'I':    break;
X    case 'F':    return (cvflonum((FLOTYPE)ival));
X    case '?':    ival = (FIXTYPE)osrand((int)ival); break;
X    default:    badiop();
X    }
X    return (cvfixnum(ival));
X    }
X    else if (floatp(arg)) {
X    fval = getflonum(arg);
X    switch (fcn) {
X    case 'A':    fval = (fval < 0.0 ? -fval : fval); break;
X    case '+':    fval += 1.0; break;
X    case '-':    fval -= 1.0; break;
X    case 'S':    fval = sin(fval); break;
X    case 'C':    fval = cos(fval); break;
X    case 'T':    fval = tan(fval); break;
X    case 's':    fval = asin(fval); break;
X    case 'c':    fval = acos(fval); break;
X    case 't':    fval = atan(fval); break;
X    case 'E':    fval = exp(fval); break;
X    case 'R':    checkfneg(fval); fval = sqrt(fval); break;
X    case 'I':    return (cvfixnum((FIXTYPE)fval));
X    case 'F':    break;
X    default:    badfop();
X    }
X    return (cvflonum(fval));
X    }
X    else
X    xlerror("bad argument type",arg);
X}
X
X/* unary predicates */
XLVAL xminusp() { return (predicate('-')); } /* minusp */
XLVAL xzerop()  { return (predicate('Z')); } /* zerop */
XLVAL xplusp()  { return (predicate('+')); } /* plusp */
XLVAL xevenp()  { return (predicate('E')); } /* evenp */
XLVAL xoddp()   { return (predicate('O')); } /* oddp */
X
X/* predicate - handle a predicate function */
XLOCAL LVAL predicate(fcn)
X  int fcn;
X{
X    FLOTYPE fval;
X    FIXTYPE ival;
X    LVAL arg;
X
X    /* get the argument */
X    arg = xlgetarg();
X    xllastarg();
X
X    /* check the argument type */
X    if (fixp(arg)) {
X    ival = getfixnum(arg);
X    switch (fcn) {
X    case '-':    ival = (ival < 0); break;
X    case 'Z':    ival = (ival == 0); break;
X    case '+':    ival = (ival > 0); break;
X    case 'E':    ival = ((ival & 1) == 0); break;
X    case 'O':    ival = ((ival & 1) != 0); break;
X    default:    badiop();
X    }
X    }
X    else if (floatp(arg)) {
X    fval = getflonum(arg);
X    switch (fcn) {
X    case '-':    ival = (fval < 0); break;
X    case 'Z':    ival = (fval == 0); break;
X    case '+':    ival = (fval > 0); break;
X    default:    badfop();
X    }
X    }
X    else
X    xlerror("bad argument type",arg);
X
X    /* return the result value */
X    return (ival ? true : NIL);
X}
X
X/* comparison functions */
XLVAL xlss() { return (compare('<')); } /* < */
XLVAL xleq() { return (compare('L')); } /* <= */
XLVAL xequ() { return (compare('=')); } /* = */
XLVAL xneq() { return (compare('#')); } /* /= */
XLVAL xgeq() { return (compare('G')); } /* >= */
XLVAL xgtr() { return (compare('>')); } /* > */
X
X/* compare - common compare function */
XLOCAL LVAL compare(fcn)
X  int fcn;
X{
X    FIXTYPE icmp,ival,iarg;
X    FLOTYPE fcmp,fval,farg;
X    LVAL arg;
X    int mode;
X
X    /* get the first argument */
X    arg = xlgetarg();
X
X    /* set the type of the first argument */
X    if (fixp(arg)) {
X    ival = getfixnum(arg);
X    mode = 'I';
X    }
X    else if (floatp(arg)) {
X    fval = getflonum(arg);
X    mode = 'F';
X    }
X    else
X    xlerror("bad argument type",arg);
X
X    /* handle each remaining argument */
X    for (icmp = TRUE; icmp && moreargs(); ival = iarg, fval = farg) {
X
X    /* get the next argument */
X    arg = xlgetarg();
X
X    /* check its type */
X    if (fixp(arg)) {
X        switch (mode) {
X        case 'I':
X            iarg = getfixnum(arg);
X            break;
X        case 'F':
X            farg = (FLOTYPE)getfixnum(arg);
X        break;
X        }
X    }
X    else if (floatp(arg)) {
X        switch (mode) {
X        case 'I':
X            fval = (FLOTYPE)ival;
X        farg = getflonum(arg);
X        mode = 'F';
X        break;
X        case 'F':
X            farg = getflonum(arg);
X        break;
X        }
X    }
X    else
X        xlerror("bad argument type",arg);
X
X    /* compute result of the compare */
X    switch (mode) {
X    case 'I':
X        icmp = ival - iarg;
X        switch (fcn) {
X        case '<':    icmp = (icmp < 0); break;
X        case 'L':    icmp = (icmp <= 0); break;
X        case '=':    icmp = (icmp == 0); break;
X        case '#':    icmp = (icmp != 0); break;
X        case 'G':    icmp = (icmp >= 0); break;
X        case '>':    icmp = (icmp > 0); break;
X        }
X        break;
X    case 'F':
X        fcmp = fval - farg;
X        switch (fcn) {
X        case '<':    icmp = (fcmp < 0.0); break;
X        case 'L':    icmp = (fcmp <= 0.0); break;
X        case '=':    icmp = (fcmp == 0.0); break;
X        case '#':    icmp = (fcmp != 0.0); break;
X        case 'G':    icmp = (fcmp >= 0.0); break;
X        case '>':    icmp = (fcmp > 0.0); break;
X        }
X        break;
X    }
X    }
X
X    /* return the result */
X    return (icmp ? true : NIL);
X}
X
X/* badiop - bad integer operation */
XLOCAL badiop()
X{
X    xlfail("bad integer operation");
X}
X
X/* badfop - bad floating point operation */
XLOCAL badfop()
X{
X    xlfail("bad floating point operation");
X}
END_OF_FILE
if test 11975 -ne `wc -c <'src/xlisp/xcore/c/xlmath.c'`; then
    echo shar: \"'src/xlisp/xcore/c/xlmath.c'\" unpacked with wrong size!
fi
# end of 'src/xlisp/xcore/c/xlmath.c'
fi
if test -f 'src/xlisp/xcore/c/xlstruct.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'src/xlisp/xcore/c/xlstruct.c'\"
else
echo shar: Extracting \"'src/xlisp/xcore/c/xlstruct.c'\" \(12885 characters\)
sed "s/^X//" >'src/xlisp/xcore/c/xlstruct.c' <<'END_OF_FILE'
X/* -*-C-*-
X********************************************************************************
X*
X* File:         xlstruct.c
X* RCS:          $Header: xlstruct.c,v 1.2 89/11/25 05:47:24 mayer Exp $
X* Description:  the defstruct facility
X* Author:       David Michael Betz
X* Created:
X* Modified:     Sat Nov 25 05:47:17 1989 (Niels Mayer) mayer@hplnpm
X* Language:     C
X* Package:      N/A
X* Status:       X11r4 contrib tape release
X*
X* WINTERP 1.0 Copyright 1989 Hewlett-Packard Company (by Niels Mayer).
X* XLISP version 2.1, Copyright (c) 1989, by David Betz.
X*
X* Permission to use, copy, modify, distribute, and sell this software and its
X* documentation for any purpose is hereby granted without fee, provided that
X* the above copyright notice appear in all copies and that both that
X* copyright notice and this permission notice appear in supporting
X* documentation, and that the name of Hewlett-Packard and David Betz not be
X* used in advertising or publicity pertaining to distribution of the software
X* without specific, written prior permission.  Hewlett-Packard and David Betz
X* make no representations about the suitability of this software for any
X* purpose. It is provided "as is" without express or implied warranty.
X*
X* HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS
X* SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS,
X* IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL,
X* INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
X* LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
X* OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
X* PERFORMANCE OF THIS SOFTWARE.
X*
X* See ./winterp/COPYRIGHT for information on contacting the authors.
X*
X* Please send modifications, improvements and bugfixes to [e-mail]
X* Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x
X*
X********************************************************************************
X*/
Xstatic char rcs_identity[] = "@(#)$Header: xlstruct.c,v 1.2 89/11/25 05:47:24 mayer Exp $";
X
X
X#include "xlisp.h"
X
X/* external variables */
Xextern LVAL xlenv,xlfenv;
Xextern LVAL s_lambda,s_quote,lk_key,true;
Xextern char buf[];
X
X/* local variables */
Xstatic prefix[STRMAX+1];
X
X/* xmkstruct - the '%make-struct' function */
XLVAL xmkstruct()
X{
X    LVAL type,val;
X    int i;
X
X    /* get the structure type */
X    type = xlgasymbol();
X
X    /* make the structure */
X    val = newstruct(type,xlargc);
X
X    /* store each argument */
X    for (i = 1; moreargs(); ++i)
X    setelement(val,i,nextarg());
X    xllastarg();
X
X    /* return the structure */
X    return (val);
X}
X
X/* xcpystruct - the '%copy-struct' function */
XLVAL xcpystruct()
X{
X    LVAL str,val;
X    int size,i;
X    str = xlgastruct();
X    xllastarg();
X    size = getsz(str);
X    val = newstruct(getelement(str,0),size-1);
X    for (i = 1; i < size; ++i)
X    setelement(val,i,getelement(str,i));
X    return (val);
X}
X
X/* xstrref - the '%struct-ref' function */
XLVAL xstrref()
X{
X    LVAL str,val;
X    int i;
X    str = xlgastruct();
X    val = xlgafixnum(); i = (int)getfixnum(val);
X    xllastarg();
X    return (getelement(str,i));
X}
X
X/* xstrset - the '%struct-set' function */
XLVAL xstrset()
X{
X    LVAL str,val;
X    int i;
X    str = xlgastruct();
X    val = xlgafixnum(); i = (int)getfixnum(val);
X    val = xlgetarg();
X    xllastarg();
X    setelement(str,i,val);
X    return (val);
X}
X
X/* xstrtypep - the '%struct-type-p' function */
XLVAL xstrtypep()
X{
X    LVAL type,val;
X    type = xlgasymbol();
X    val = xlgetarg();
X    xllastarg();
X    return (structp(val) && getelement(val,0) == type ? true : NIL);
X}
X
X/* xdefstruct - the 'defstruct' special form */
XLVAL xdefstruct()
X{
X    LVAL structname,slotname,defexpr,sym,tmp,args,body;
X    LVAL options,oargs,slots;
X    char *pname;
X    int slotn;
X
X    /* protect some pointers */
X    xlstkcheck(6);
X    xlsave(structname);
X    xlsave(slotname);
X    xlsave(defexpr);
X    xlsave(args);
X    xlsave(body);
X    xlsave(tmp);
X
X    /* initialize */
X    args = body = NIL;
X    slotn = 0;
X
X    /* get the structure name */
X    tmp = xlgetarg();
X    if (symbolp(tmp)) {
X    structname = tmp;
X    strcpy(prefix,getstring(getpname(structname)));
X    strcat(prefix,"-");
X    }
X
X    /* get the structure name and options */
X    else if (consp(tmp) && symbolp(car(tmp))) {
X    structname = car(tmp);
X    strcpy(prefix,getstring(getpname(structname)));
X    strcat(prefix,"-");
X
X    /* handle the list of options */
X    for (options = cdr(tmp); consp(options); options = cdr(options)) {
X
X        /* get the next argument */
X        tmp = car(options);
X
X        /* handle options that don't take arguments */
X        if (symbolp(tmp)) {
X        pname = (char *) getstring(getpname(tmp));
X        xlerror("unknown option",tmp);
X        }
X
X        /* handle options that take arguments */
X        else if (consp(tmp) && symbolp(car(tmp))) {
X        pname = (char *) getstring(getpname(car(tmp)));
X        oargs = cdr(tmp);
X
X        /* check for the :CONC-NAME keyword */
X        if (strcmp(pname,":CONC-NAME") == 0) {
X
X            /* get the name of the structure to include */
X            if (!consp(oargs) || !symbolp(car(oargs)))
X            xlerror("expecting a symbol",oargs);
X
X            /* save the prefix */
X            strcpy(prefix,getstring(getpname(car(oargs))));
X        }
X
X        /* check for the :INCLUDE keyword */
X        else if (strcmp(pname,":INCLUDE") == 0) {
X
X            /* get the name of the structure to include */
X            if (!consp(oargs) || !symbolp(car(oargs)))
X            xlerror("expecting a structure name",oargs);
X            tmp = car(oargs);
X            oargs = cdr(oargs);
X
X            /* add each slot from the included structure */
X            slots = xlgetprop(tmp,xlenter("*STRUCT-SLOTS*"));
X            for (; consp(slots); slots = cdr(slots)) {
X            if (consp(car(slots)) && consp(cdr(car(slots)))) {
X
X                /* get the next slot description */
X                tmp = car(slots);
X
X                /* create the slot access functions */
X                addslot(car(tmp),car(cdr(tmp)),++slotn,&args,&body);
X            }
X            }
X
X            /* handle slot initialization overrides */
X            for (; consp(oargs); oargs = cdr(oargs)) {
X            tmp = car(oargs);
X            if (symbolp(tmp)) {
X                slotname = tmp;
X                defexpr = NIL;
X            }
X            else if (consp(tmp) && symbolp(car(tmp))) {
X                slotname = car(tmp);
X                defexpr = (consp(cdr(tmp)) ? car(cdr(tmp)) : NIL);
X            }
X            else
X                xlerror("bad slot description",tmp);
X            updateslot(args,slotname,defexpr);
X            }
X        }
X        else
X            xlerror("unknown option",tmp);
X        }
X        else
X        xlerror("bad option syntax",tmp);
X    }
X    }
X
X    /* get each of the structure members */
X    while (moreargs()) {
X
X    /* get the slot name and default value expression */
X    tmp = xlgetarg();
X    if (symbolp(tmp)) {
X        slotname = tmp;
X        defexpr = NIL;
X    }
X    else if (consp(tmp) && symbolp(car(tmp))) {
X        slotname = car(tmp);
X        defexpr = (consp(cdr(tmp)) ? car(cdr(tmp)) : NIL);
X    }
X    else
X        xlerror("bad slot description",tmp);
X
X    /* create a closure for non-trival default expressions */
X    if (defexpr != NIL) {
X        tmp = newclosure(NIL,s_lambda,xlenv,xlfenv);
X        setbody(tmp,cons(defexpr,NIL));
X        tmp = cons(tmp,NIL);
X        defexpr = tmp;
X    }
X
X    /* create the slot access functions */
X    addslot(slotname,defexpr,++slotn,&args,&body);
X    }
X
X    /* store the slotnames and default expressions */
X    xlputprop(structname,args,xlenter("*STRUCT-SLOTS*"));
X
X    /* enter the MAKE-xxx symbol */
X    sprintf(buf,"MAKE-%s",getstring(getpname(structname)));
X    sym = xlenter(buf);
X
X    /* make the MAKE-xxx function */
X    args = cons(lk_key,args);
X    tmp = cons(structname,NIL);
X    tmp = cons(s_quote,tmp);
X    body = cons(tmp,body);
X    body = cons(xlenter("%MAKE-STRUCT"),body);
X    body = cons(body,NIL);
X    setfunction(sym,
X        xlclose(sym,s_lambda,args,body,xlenv,xlfenv));
X
X    /* enter the xxx-P symbol */
X    sprintf(buf,"%s-P",getstring(getpname(structname)));
X    sym = xlenter(buf);
X
X    /* make the xxx-P function */
X    args = cons(xlenter("X"),NIL);
X    body = cons(xlenter("X"),NIL);
X    tmp = cons(structname,NIL);
X    tmp = cons(s_quote,tmp);
X    body = cons(tmp,body);
X    body = cons(xlenter("%STRUCT-TYPE-P"),body);
X    body = cons(body,NIL);
X    setfunction(sym,
X        xlclose(sym,s_lambda,args,body,NIL,NIL));
X
X    /* enter the COPY-xxx symbol */
X    sprintf(buf,"COPY-%s",getstring(getpname(structname)));
X    sym = xlenter(buf);
X
X    /* make the COPY-xxx function */
X    args = cons(xlenter("X"),NIL);
X    body = cons(xlenter("X"),NIL);
X    body = cons(xlenter("%COPY-STRUCT"),body);
X    body = cons(body,NIL);
X    setfunction(sym,
X        xlclose(sym,s_lambda,args,body,NIL,NIL));
X
X    /* restore the stack */
X    xlpopn(6);
X
X    /* return the structure name */
X    return (structname);
X}
X
X/* xlrdstruct - convert a list to a structure (used by the reader) */
XLVAL xlrdstruct(list)
X  LVAL list;
X{
X    LVAL structname,sym,slotname,expr,last,val;
X
X    /* protect the new structure */
X    xlsave1(expr);
X
X    /* get the structure name */
X    if (!consp(list) || !symbolp(car(list)))
X    xlerror("bad structure initialization list",list);
X    structname = car(list);
X    list = cdr(list);
X
X    /* enter the MAKE-xxx symbol */
X    sprintf(buf,"MAKE-%s",getstring(getpname(structname)));
X
X    /* initialize the MAKE-xxx function call expression */
X    expr = cons(xlenter(buf),NIL);
X    last = expr;
X
X    /* turn the rest of the initialization list into keyword arguments */
X    while (consp(list) && consp(cdr(list))) {
X
X    /* get the slot keyword name */
X    slotname = car(list);
X    if (!symbolp(slotname))
X        xlerror("expecting a slot name",slotname);
X    sprintf(buf,":%s",getstring(getpname(slotname)));
X
X    /* add the slot keyword */
X    rplacd(last,cons(xlenter(buf),NIL));
X    last = cdr(last);
X    list = cdr(list);
X
X    /* add the value expression */
X    rplacd(last,cons(car(list),NIL));
X    last = cdr(last);
X    list = cdr(list);
X    }
X
X    /* make sure all of the initializers were used */
X    if (consp(list))
X    xlerror("bad structure initialization list",list);
X
X    /* invoke the creation function */
X    val = xleval(expr);
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the new structure */
X    return (val);
X}
X
X/* xlprstruct - print a structure (used by printer) */
Xxlprstruct(fptr,vptr,flag)
X  LVAL fptr,vptr; int flag;
X{
X    LVAL next;
X    int i,n;
X    xlputc(fptr,'#'); xlputc(fptr,'S'); xlputc(fptr,'(');
X    xlprint(fptr,getelement(vptr,0),flag);
X    next = xlgetprop(getelement(vptr,0),xlenter("*STRUCT-SLOTS*"));
X    for (i = 1, n = getsz(vptr) - 1; i <= n && consp(next); ++i) {
X    if (consp(car(next))) { /* should always succeed */
X        xlputc(fptr,' ');
X        xlprint(fptr,car(car(next)),flag);
X        xlputc(fptr,' ');
X        xlprint(fptr,getelement(vptr,i),flag);
X    }
X    next = cdr(next);
X    }
X    xlputc(fptr,')');
X}
X
X/* addslot - make the slot access functions */
XLOCAL addslot(slotname,defexpr,slotn,pargs,pbody)
X  LVAL slotname,defexpr; int slotn; LVAL *pargs,*pbody;
X{
X    LVAL sym,args,body,tmp;
X
X    /* protect some pointers */
X    xlstkcheck(4);
X    xlsave(sym);
X    xlsave(args);
X    xlsave(body);
X    xlsave(tmp);
X
X    /* construct the update function name */
X    sprintf(buf,"%s%s",prefix,getstring(getpname(slotname)));
X    sym = xlenter(buf);
X
X    /* make the access function */
X    args = cons(xlenter("S"),NIL);
X    body = cons(cvfixnum((FIXTYPE)slotn),NIL);
X    body = cons(xlenter("S"),body);
X    body = cons(xlenter("%STRUCT-REF"),body);
X    body = cons(body,NIL);
X    setfunction(sym,
X        xlclose(sym,s_lambda,args,body,NIL,NIL));
X
X    /* make the update function */
X    args = cons(xlenter("V"),NIL);
X    args = cons(xlenter("S"),args);
X    body = cons(xlenter("V"),NIL);
X    body = cons(cvfixnum((FIXTYPE)slotn),body);
X    body = cons(xlenter("S"),body);
X    body = cons(xlenter("%STRUCT-SET"),body);
X    body = cons(body,NIL);
X    xlputprop(sym,
X          xlclose(NIL,s_lambda,args,body,NIL,NIL),
X          xlenter("*SETF*"));
X
X    /* add the slotname to the make-xxx keyword list */
X    tmp = cons(defexpr,NIL);
X    tmp = cons(slotname,tmp);
X    tmp = cons(tmp,NIL);
X    if ((args = *pargs) == NIL)
X    *pargs = tmp;
X    else {
X    while (cdr(args) != NIL)
X        args = cdr(args);
X    rplacd(args,tmp);
X    }
X
X    /* add the slotname to the %make-xxx argument list */
X    tmp = cons(slotname,NIL);
X    if ((body = *pbody) == NIL)
X    *pbody = tmp;
X    else {
X    while (cdr(body) != NIL)
X        body = cdr(body);
X    rplacd(body,tmp);
X    }
X
X    /* restore the stack */
X    xlpopn(4);
X}
X
X/* updateslot - update a slot definition */
XLOCAL updateslot(args,slotname,defexpr)
X  LVAL args,slotname,defexpr;
X{
X    LVAL tmp;
X    for (; consp(args); args = cdr(args))
X    if (slotname == car(car(args))) {
X        if (defexpr != NIL) {
X        xlsave1(tmp);
X        tmp = newclosure(NIL,s_lambda,xlenv,xlfenv);
X        setbody(tmp,cons(defexpr,NIL));
X        tmp = cons(tmp,NIL);
X        defexpr = tmp;
X        xlpop();
X        }
X        rplaca(cdr(car(args)),defexpr);
X        break;
X    }
X    if (args == NIL)
X    xlerror("unknown slot name",slotname);
X}
END_OF_FILE
if test 12885 -ne `wc -c <'src/xlisp/xcore/c/xlstruct.c'`; then
    echo shar: \"'src/xlisp/xcore/c/xlstruct.c'\" unpacked with wrong size!
fi
# end of 'src/xlisp/xcore/c/xlstruct.c'
fi
echo shar: End of archive 6 \(of 16\).
cp /dev/null ark6isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 ; do
    if test ! -f ark${I}isdone ; then
    MISSING="${MISSING} ${I}"
    fi
done
if test "${MISSING}" = "" ; then
    echo You have unpacked all 16 archives.
    rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
    echo You still need to unpack the following archives:
    echo "        " ${MISSING}
fi
##  End of shell archive.
exit 0